unit uEDIF ;

interface

uses SysUtils ;

type

    PEdif = ^TEdif ;
    TEdif = record
        car : PEdif ;
        atom : string ;
        cdr : PEdif ;
    end ;

    EClosingParen = Exception ;
    ECell = Exception ;

function ParseEdif( aText : string ) : PEdif ;
function PrintEdif( P : PEdif ) : string ;
function GetCellCount : integer ;

function ParseList : PEdif ;
procedure FreeList( P : PEdif ) ;
function atom( P : PEdif ) : string ;
function isatom( P : PEdif ) : boolean ;


function cons( P, Q : PEdif ) : PEdif ;
function car( P : PEdif ) : PEdif ;
function cdr( P : PEdif ) : PEdif ;
function caar( P : PEdif ) : PEdif ;
function cadr( P : PEdif ) : PEdif ;
function cddr( P : PEdif ) : PEdif ;
function last( P : PEdif ) : PEdif ;
function atomis( P : PEdif ; s : string ) : boolean ;
function aatom( P : PEdif ) : string ;
function aatomis( P : PEdif ; s : string ) : boolean ;

implementation


var
    EdifList        : PEdif ;
    CellCount       : integer ;
    indent, column  : integer ;
    P               : PChar ;

function GetCellCount : integer ;
begin
    Result := CellCount ;
end ;

procedure Eat ;
begin
    inc( P ) ;
end ;

function NextChar : Char ;
begin
    Result := ')' ;
    if P^ in [ ' ', #0, #9, #13, #10 ] then begin
        repeat
            if P^ = #0 then
                Exit ;
            Eat ;
        until not ( P^ in [ ' ', #9, #13, #10 ] ) ;
        if P^ <> ')' then
            Result := ' ' ;
    end
    else
        Result := P^ ;
end ;

function EatChar( c : Char ) : boolean ;
begin
    Result := NextChar = c ;
    if Result then
        Eat ;
end ;

function NextToken : string ;
begin
    Result := '' ;
    case NextChar of
        '(' : begin
                Result := P^ ;
                Eat ;
            end ;
        ')' : begin
                Result := P^ ;
                Eat ;
            end ;
        '"' : begin
                repeat
                    Result := Result + P^ ;
                    Eat ;
                until P^ in [ '"', #0 ] ;
                Result := Result + P^ ;
                Eat ;
            end ;
        ' ' : begin
                Eat ;
                Result := NextToken ;
            end ;
    else
        while not ( NextChar in [ ' ', '(', ')' ] ) do begin
            Result := Result + P^ ;
            Eat ;
        end ;
    end ;
end ;

function NewAtom( s : string ) : PEdif ;
begin
    New( Result ) ;
    Result^.car := nil ;
    Result^.atom := s ;
    Result^.cdr := nil ;
end ;

function cons( P, Q : PEdif ) : PEdif ;
begin
    New( Result ) ;
    inc( CellCount ) ;
    Result^.car := P ;
    Result^.atom := '' ;
    Result^.cdr := Q ;
end ;

function ParseObject : PEdif ;
begin
    if NextChar = '(' then
        Result := Cons( ParseList, nil )
    else
        Result := NewAtom( NextToken ) ;
end ;

function ParseList : PEdif ;
var
    L, R            : PEdif ;
begin
    Result := nil ;
    EatChar( ' ' ) ;
    EatChar( '(' ) ;
    if NextChar = ')' then
        raise EClosingParen.Create( 'Error: ")" not expected' ) ;
    L := ParseObject ;
    R := L ;
    repeat
        if NextChar = ')' then begin
            EatChar( ')' ) ;
            Result := L ;
        end
        else begin
            R^.cdr := ParseObject ;
            R := R^.cdr ;
        end ;
    until Result <> nil ;
end ;

function ParseEdif( aText : string ) : PEdif ;
begin
    P := PChar( aText ) ;
    CellCount := 0 ;
    Result := ParseList ;
end ;

function car( P : PEdif ) : PEdif ;
begin
    if assigned( P ) then
        Result := P^.car
    else
        raise ECell.Create( '"car" failed' ) ;
end ;

function cdr( P : PEdif ) : PEdif ;
begin
    if assigned( P ) then
        Result := P^.cdr
    else
        raise ECell.Create( '"cdr" failed' ) ;
end ;

function caar( P : PEdif ) : PEdif ;
begin
    if assigned( P ) and assigned( P^.car ) then
        Result := P^.car^.car
    else
        raise ECell.Create( '"caar" failed' ) ;
end ;

function cadr( P : PEdif ) : PEdif ;
begin
    if assigned( P ) and assigned( P^.cdr ) then
        Result := P^.cdr^.car
    else
        raise ECell.Create( '"cadr" failed' ) ;
end ;

function cddr( P : PEdif ) : PEdif ;
begin
    if assigned( P ) and assigned( P^.cdr ) then
        Result := P^.cdr^.cdr
    else
        raise ECell.Create( '"cddr" failed' ) ;
end ;

function last( P : PEdif ) : PEdif ;
begin
    if not assigned( P ) then
        raise ECell.Create( 'P = nil' ) ;
    repeat
        Result := P ;
        P := P^.cdr ;
    until not assigned( P ) ;
end ;

function atom( P : PEdif ) : string ;
begin
    if assigned( P ) and not assigned( P^.car ) then
        Result := P^.atom
    else
        raise ECell.Create( '"atom" failed' ) ;   //      Result := '?atom?' ;
end ;

function isatom( P : PEdif ) : boolean ;
begin
    Result := not assigned( P^.car ) ;
end ;

function atomis( P : PEdif ; s : string ) : boolean ;
begin
    Result := assigned( P ) and isatom( P ) and ( LowerCase( atom( P ) ) = LowerCase( s ) ) ;
end ;

function aatom( P : PEdif ) : string ;
begin
    if assigned( P ) and assigned( P^.car ) and not assigned( P^.car^.car ) then
        Result := car( P )^.atom
    else
        raise ECell.Create( '"aatom" failed' ) ;
end ;

function aatomis( P : PEdif ; s : string ) : boolean ;
begin
    Result := LowerCase( aatom( P ) ) = s ;
end ;

function PrintEdif( P : PEdif ) : string ;
var
    Text            : string ;

    procedure PrintList( P : PEdif ) ;
    var
        k           : integer ;
    begin
        inc( indent ) ;
        while P <> nil do begin
            Text := Text + ' ' ;
            inc( column ) ;
            if P^.car <> nil then begin
                Text := Text + #13 ;
                for k := 1 to indent do
                    Text := Text + '  ' ;
                column := 2 * indent ;
                Text := Text + '(' ;
                inc( column ) ;
                PrintList( P^.car ) ;
                Text := Text + ' )' ;
                inc( column, 2 ) ;
            end
            else begin
                Text := Text + P^.atom ;
                column := column + length( P^.atom ) ;
            end ;
            P := P^.cdr ;
        end ;
        dec( indent ) ;
    end ;

begin
    indent := 0 ;
    column := 0 ;
    PrintList( P ) ;
    Result := '(' + Text + #13')' ;
end ;

procedure FreeList( P : PEdif ) ;
begin
    if assigned( P ) then begin
        FreeList( P.car ) ;
        FreeList( P.cdr ) ;
        Dispose( P ) ;
    end ;
end ;

initialization
    EdifList := nil ;

finalization
    if assigned( EdifList ) then
        FreeList( EdifList ) ;

end.

